home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1998 November / Freeware November 1998.img / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / nneething.el.z / nneething.el
Lisp/Scheme  |  1998-10-27  |  11KB  |  357 lines
  1. ;;; nneething.el --- random file access for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  28. ;; For an overview of what the interface functions do, please see the
  29. ;; Gnus sources.  
  30.  
  31. ;;; Code:
  32.  
  33. (require 'nnheader)
  34. (require 'nnmail)
  35. (require 'nnoo)
  36. (eval-when-compile (require 'cl))
  37.  
  38. (nnoo-declare nneething)
  39.  
  40. (defvoo nneething-map-file-directory "~/.nneething/"
  41.   "*Where nneething stores the map files.")
  42.  
  43. (defvoo nneething-map-file ".nneething"
  44.   "*Name of the map files.")
  45.  
  46. (defvoo nneething-exclude-files nil
  47.   "*Regexp saying what files to exclude from the group.
  48. If this variable is nil, no files will be excluded.")
  49.  
  50.  
  51.  
  52. ;;; Internal variables. 
  53.  
  54. (defconst nneething-version "nneething 1.0"
  55.   "nneething version.")
  56.  
  57. (defvoo nneething-current-directory nil
  58.   "Current news group directory.")
  59.  
  60. (defvoo nneething-status-string "")
  61. (defvoo nneething-group-alist nil)
  62.  
  63. (defvoo nneething-message-id-number 0)
  64. (defvoo nneething-work-buffer " *nneething work*")
  65.  
  66. (defvoo nneething-directory nil)
  67. (defvoo nneething-group nil)
  68. (defvoo nneething-map nil)
  69. (defvoo nneething-read-only nil)
  70. (defvoo nneething-active nil)
  71.  
  72.  
  73.  
  74. ;;; Interface functions.
  75.  
  76. (nnoo-define-basics nneething)
  77.  
  78. (deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
  79.   (nneething-possibly-change-directory group)
  80.  
  81.   (save-excursion
  82.     (set-buffer nntp-server-buffer)
  83.     (erase-buffer)
  84.     (let* ((number (length articles))
  85.        (count 0)
  86.        (large (and (numberp nnmail-large-newsgroup)
  87.                (> number nnmail-large-newsgroup)))
  88.        article file)
  89.  
  90.       (if (stringp (car articles))
  91.       'headers
  92.  
  93.     (while (setq article (pop articles))
  94.       (setq file (nneething-file-name article))
  95.  
  96.       (when (and (file-exists-p file)
  97.              (or (file-directory-p file)
  98.              (not (zerop (nnheader-file-size file)))))
  99.         (insert (format "221 %d Article retrieved.\n" article))
  100.         (nneething-insert-head file)
  101.         (insert ".\n"))
  102.  
  103.       (incf count)
  104.  
  105.       (and large
  106.            (zerop (% count 20))
  107.            (message "nneething: Receiving headers... %d%%"
  108.             (/ (* count 100) number))))
  109.  
  110.     (when large
  111.       (message "nneething: Receiving headers...done"))
  112.  
  113.     (nnheader-fold-continuation-lines)
  114.     'headers))))
  115.  
  116. (deffoo nneething-request-article (id &optional group server buffer)
  117.   (nneething-possibly-change-directory group)
  118.   (let ((file (unless (stringp id) (nneething-file-name id)))
  119.     (nntp-server-buffer (or buffer nntp-server-buffer)))
  120.     (and (stringp file)            ; We did not request by Message-ID.
  121.      (file-exists-p file)        ; The file exists.
  122.      (not (file-directory-p file))    ; It's not a dir.
  123.      (save-excursion
  124.        (nnmail-find-file file)    ; Insert the file in the nntp buf.
  125.        (or (nnheader-article-p)    ; Either it's a real article...
  126.            (progn
  127.          (goto-char (point-min))
  128.          (nneething-make-head file (current-buffer)) ; ... or we fake some headers.
  129.          (insert "\n")))
  130.        t))))
  131.  
  132. (deffoo nneething-request-group (group &optional dir dont-check)
  133.   (nneething-possibly-change-directory group dir)
  134.   (unless dont-check
  135.     (nneething-create-mapping)
  136.     (if (> (car nneething-active) (cdr nneething-active))
  137.     (nnheader-insert "211 0 1 0 %s\n" group)
  138.       (nnheader-insert
  139.        "211 %d %d %d %s\n" 
  140.        (- (1+ (cdr nneething-active)) (car nneething-active))
  141.        (car nneething-active) (cdr nneething-active)
  142.        group)))
  143.   t)
  144.  
  145. (deffoo nneething-request-list (&optional server dir)
  146.   (nnheader-report 'nneething "LIST is not implemented."))
  147.  
  148. (deffoo nneething-request-newgroups (date &optional server)
  149.   (nnheader-report 'nneething "NEWSGROUPS is not implemented."))
  150.  
  151. (deffoo nneething-request-type (group &optional article)
  152.   'unknown)
  153.  
  154. (deffoo nneething-close-group (group &optional server)
  155.   (setq nneething-current-directory nil)
  156.   t)
  157.  
  158.  
  159. ;;; Internal functions.
  160.  
  161. (defun nneething-possibly-change-directory (group &optional dir)
  162.   (when group
  163.     (if (and nneething-group
  164.          (string= group nneething-group))
  165.     t
  166.       (let (entry)
  167.     (if (setq entry (assoc group nneething-group-alist))
  168.         (progn
  169.           (setq nneething-group group)
  170.           (setq nneething-directory (nth 1 entry))
  171.           (setq nneething-map (nth 2 entry))
  172.           (setq nneething-active (nth 3 entry)))
  173.       (setq nneething-group group)
  174.       (setq nneething-directory dir)
  175.       (setq nneething-map nil)
  176.       (setq nneething-active (cons 1 0))
  177.       (nneething-create-mapping)
  178.       (push (list group dir nneething-map nneething-active)
  179.         nneething-group-alist))))))
  180.  
  181. (defun nneething-map-file ()
  182.   ;; We make sure that the .nneething directory exists. 
  183.   (unless (file-exists-p nneething-map-file-directory)
  184.     (make-directory nneething-map-file-directory 'parents))
  185.   ;; We store it in a special directory under the user's home dir.
  186.   (concat (file-name-as-directory nneething-map-file-directory)
  187.       nneething-group nneething-map-file))
  188.  
  189. (defun nneething-create-mapping ()
  190.   ;; Read nneething-active and nneething-map.
  191.   (let ((map-file (nneething-map-file))
  192.     (files (directory-files nneething-directory))
  193.     touched map-files)
  194.     (if (file-exists-p map-file)
  195.     (condition-case nil
  196.         (load map-file nil t t)
  197.       (error nil)))
  198.     (or nneething-active (setq nneething-active (cons 1 0)))
  199.     ;; Old nneething had a different map format.
  200.     (when (and (cdar nneething-map)
  201.            (atom (cdar nneething-map)))
  202.       (setq nneething-map
  203.         (mapcar (lambda (n)
  204.               (list (cdr n) (car n) 
  205.                 (nth 5 (file-attributes 
  206.                     (nneething-file-name (car n))))))
  207.             nneething-map)))
  208.     ;; Remove files matching the exclusion regexp.
  209.     (when nneething-exclude-files
  210.       (let ((f files)
  211.         prev)
  212.     (while f
  213.       (if (string-match nneething-exclude-files (car f))
  214.           (if prev (setcdr prev (cdr f))
  215.         (setq files (cdr files)))
  216.         (setq prev f))
  217.       (setq f (cdr f)))))
  218.     ;; Remove deleted files from the map.
  219.     (let ((map nneething-map)
  220.       prev)
  221.       (while map
  222.     (if (and (member (cadar map) files)
  223.          ;; We also remove files that have changed mod times.
  224.          (equal (nth 5 (file-attributes
  225.                 (nneething-file-name (cadar map))))
  226.             (caddar map)))
  227.         (progn
  228.           (push (cadar map) map-files)
  229.           (setq prev map))
  230.       (setq touched t)
  231.       (if prev
  232.           (setcdr prev (cdr map))
  233.         (setq nneething-map (cdr nneething-map))))
  234.     (setq map (cdr map))))
  235.     ;; Find all new files and enter them into the map.
  236.     (while files
  237.       (unless (member (car files) map-files) 
  238.     ;; This file is not in the map, so we enter it.
  239.     (setq touched t)
  240.     (setcdr nneething-active (1+ (cdr nneething-active)))
  241.     (push (list (cdr nneething-active) (car files) 
  242.             (nth 5 (file-attributes
  243.                 (nneething-file-name (car files)))))
  244.           nneething-map))
  245.       (setq files (cdr files)))
  246.     (when (and touched 
  247.            (not nneething-read-only))
  248.       (save-excursion
  249.     (nnheader-set-temp-buffer " *nneething map*")
  250.     (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
  251.         "(setq nneething-active '" (prin1-to-string nneething-active)
  252.         ")\n")
  253.     (write-region (point-min) (point-max) map-file nil 'nomesg)
  254.     (kill-buffer (current-buffer))))))
  255.  
  256. (defun nneething-insert-head (file)
  257.   "Insert the head of FILE."
  258.   (when (nneething-get-head file)
  259.     (insert-buffer-substring nneething-work-buffer)
  260.     (goto-char (point-max))))
  261.  
  262. (defun nneething-make-head (file &optional buffer)
  263.   "Create a head by looking at the file attributes of FILE."
  264.   (let ((atts (file-attributes file)))
  265.     (insert 
  266.      "Subject: " (file-name-nondirectory file) "\n"
  267.      "Message-ID: <nneething-" 
  268.      (int-to-string (incf nneething-message-id-number))
  269.      "@" (system-name) ">\n"
  270.      (if (equal '(0 0) (nth 5 atts)) ""
  271.        (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
  272.      (or (if buffer
  273.          (save-excursion 
  274.            (set-buffer buffer)
  275.            (if (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
  276.            (concat "From: " (match-string 0) "\n"))))
  277.      (nneething-from-line (nth 2 atts) file))
  278.      (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
  279.      (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
  280.        "")
  281.      (if buffer 
  282.      (save-excursion
  283.        (set-buffer buffer)
  284.        (concat "Lines: " (int-to-string 
  285.                   (count-lines (point-min) (point-max))) "\n"))
  286.        "")
  287.      )))
  288.  
  289. (defun nneething-from-line (uid &optional file)
  290.   "Return a From header based of UID."
  291.   (let* ((login (condition-case nil 
  292.             (user-login-name uid)
  293.           (error 
  294.            (cond ((= uid (user-uid)) (user-login-name))
  295.              ((zerop uid) "root")
  296.              (t (int-to-string uid))))))
  297.      (name (condition-case nil 
  298.            (user-full-name uid)
  299.          (error 
  300.           (cond ((= uid (user-uid)) (user-full-name))
  301.             ((zerop uid) "Ms. Root")))))
  302.      (host (if  (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
  303.            (prog1
  304.                (substring file 
  305.                   (match-beginning 1) 
  306.                   (match-end 1))
  307.              (if (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
  308.              (setq login (substring file
  309.                         (match-beginning 2)
  310.                         (match-end 2))
  311.                    name nil)))
  312.          (system-name))))
  313.     (concat "From: " login "@" host 
  314.         (if name (concat " (" name ")") "") "\n")))
  315.  
  316. (defun nneething-get-head (file)
  317.   "Either find the head in FILE or make a head for FILE."
  318.   (save-excursion
  319.     (set-buffer (get-buffer-create nneething-work-buffer))
  320.     (setq case-fold-search nil)
  321.     (buffer-disable-undo (current-buffer))
  322.     (erase-buffer)
  323.     (cond 
  324.      ((not (file-exists-p file))
  325.       ;; The file do not exist. 
  326.       nil)
  327.      ((or (file-directory-p file)
  328.       (file-symlink-p file))
  329.       ;; It's a dir, so we fudge a head.
  330.       (nneething-make-head file) t)
  331.      (t 
  332.       ;; We examine the file.
  333.       (nnheader-insert-head file)
  334.       (if (nnheader-article-p)
  335.       (delete-region 
  336.        (progn
  337.          (goto-char (point-min))
  338.          (or (and (search-forward "\n\n" nil t)
  339.               (1- (point)))
  340.          (point-max)))
  341.        (point-max))
  342.     (goto-char (point-min))
  343.     (nneething-make-head file (current-buffer))
  344.     (delete-region (point) (point-max)))
  345.       t))))
  346.  
  347. (defun nneething-file-name (article)
  348.   "Return the file name of ARTICLE."
  349.   (concat (file-name-as-directory nneething-directory)
  350.       (if (numberp article)
  351.           (cadr (assq article nneething-map))
  352.         article)))
  353.  
  354. (provide 'nneething)
  355.  
  356. ;;; nneething.el ends here
  357.